BOI '96, Nicosia, octombrie 1996
Problema 3 (Cap si stema):

Se da o matrice NxN (N<=10) de monezi, fiecare avand vizibila capul(H)
sau stema (T). Un jucator trebuie sa intoarca monezile, astfel ca in
final, toate sa fie cu stema in sus. Regula consta in aceea ca daca se
intoarce o moneda, atunci se intorc automat si toate monezile adiacente 
(stanga, dreapta, sus, jos - daca exista).

Problema cere ca - plecand de la o configuratie initiala - sa se ajunga
la o matrice numai cu stema, efectuand un numar minim de "intoarceri".
Remarca: prin "intoarcere" se intelege: "se fixeaza o moneda si aceasta
se intoarce impreuna cu vecinele ei".

Intrare (fisier INPUT.TXT):
Prima linie contine numarul intreg N. Pe fiecare din urmatoarele N 
linii se gasesc cate N caractere de forma H (cap) sau T (stema).

Iesire (fisier OUTPUT.TXT):
Prima linie va contine numarul minim de intoarceri. Urmatoarele N linii
reprezinta o matrice cu cate N numere intregi (0 sau 1) pe fiecare
linie. Valoarea 1 inseamna ca moneda a fost cel putin odata folosita
pentru o intoarcere); valoarea 0 arata ca moneda de pe pozitia 
respectiva nu a provocat nici o intoarcere.

Exemplu:
Intrare				Iesire:
3				5
H T T				1 0 0
H T T				0 1 0
T T T				1 1 1

Remarca: Se presupune ca problema are totdeauna solutie.

Timp maxim per test: 20 secunde.
Punctaj maxim: 40 puncte.
=================================
test 1 (5 p)
Intrare:
3
H T T
H T T
T T T
Iesire:
5
1 0 0
0 1 0
1 1 1
---------------
Test 2 (7 p)
Intrare:
4
H H H H
H T T H
H T T H
H H H H
Iesire:
4
1 0 0 1
0 0 0 0
0 0 0 0
1 0 0 1
----------------
Test 3 (8 p)
Intrare:
4
H T H H
H H T H
H H H T
H T T H
Iesire:
4
0 0 0 1
1 0 0 0
0 0 0 0
0 1 1 0
------
Test 4 (9 p)
intrare:
4
H T T T
T H T T
T T H T
T T T H
Iesire:
4
1 0 0 0      0 0 0 0
0 1 0 0 sau: 1 0 0 0
0 0 1 0      1 0 0 0
0 0 0 1      0 1 1 0
------------
Test 5 (11 p)
5
H T T H T
T T T H H
T T H H H
H H H H H
T T H T T
Iesire:
8
1 0 0 1 0
0 1 1 0 1
0 0 0 0 0
0 1 0 1 0
0 0 1 0 0
-------
===============================
Solutia 1 (Mihai Badoiu)
{$A+,B-,D-,E-,F-,G+,I-,L-,N-,O-,P-,Q-,R-,S-,T-,V+,X+,Y-}
{$M 65520,0,655360}
const
	vtmp:array[1..10] of integer=
(100,100,100,100,4,4,3,3,3,3);

type
	tcasuta=array[0..11] of integer;
	plista=^lista;
	lista=record
		v: tcasuta;
		cst: integer;
		a,b:integer;
		parinte: plista;
		next: plista;
		end;

var
	EUR:integer;
	ct:array[0..100,0..10,0..10] of plista;
	cost_opt: integer;
{	sol: integer;}
	n: integer;
	root, last: plista;

function disp1(p:plista):integer;
var
	i,k,t:integer;
begin
	k:=0;
	for i:=1 to n do
		k:=k xor p^.v[i];
	t:=0;
	for i:=0 to n-1 do
	if ((k shr i) and 1=1) then
		inc(t);
	disp1:=t;
end;

function disp2(p:plista):integer;
var
	i,k,t:integer;
begin
	k:=0;
	for i:=1 to n do
		k:=k xor (p^.v[i] shl (i mod 2));
	t:=0;
	for i:=0 to n-1 do
	if ((k shr i) and 1=1) then
		inc(t);
	disp2:=t;
end;

procedure scrie;
var
	f:text;
	t:array[1..10,1..10] of integer;
	i,j,k:integer;
	p:plista;
begin
	for i:=1 to n do
		for j:=1 to n do
			t[i,j]:=0;
	k:=0;
	assign(f,'output.txt');
	rewrite(f);
	p:=last;
	while p^.parinte<>nil do
	begin
		if t[p^.a,p^.b]=0 then
		begin
			t[p^.a,p^.b]:=1;
			inc(k);
			end
		else
		begin
			t[p^.a,p^.b]:=0;
			dec(k);
			end;
		p:=p^.parinte;
		end;
	writeln(f,k);
	for i:=1 to n do
	begin
		write(f,t[i,1]);
		for j:=2 to n do
			write(f,' ',t[i,j]);
		writeln(f);
		end;
	close(f);
end;

procedure term;
var
	i:integer;
begin
	for i:=1 to n do
	if last^.v[i]<>0 then
		exit;
	scrie;
	halt;
end;

procedure init(p:plista);
var
	i:integer;
begin
	for i:=0 to n+1 do
		p^.v[i]:=0;
end;

procedure calc_cost(p:plista);
var
	i,k,j: integer;
begin
	j:=0;
	for i:=1 to n do
	begin
		k:=p^.v[i];
		while k<>0 do
		begin
			if k and 1=1 then
				inc(j);
			k:=k shr 1;
			end;
		end;
	p^.cst:=j;
end;

procedure sch(p:plista;a,b:integer);
begin
	p^.v[a]:=p^.v[a] xor (1 shl (b-1));
end;

procedure load;
var
	f:text;
	i,j:integer;
	ch: char;
begin
	assign(f,'input.txt');
	reset(f);
	readln(f,n);
	new(root);
	root^.next:=nil;
	root^.parinte:=nil;
	init(root);
	last:=root;
	for i:=1 to n do
	begin
		for j:=1 to n do
		repeat
			read(f,ch);
			if ch<>' ' then
			begin
				if upcase(ch)='H' then
					sch(root,i,j);
				end;
			until (ch<>' ');
		readln(f);
		end;
	calc_cost(root);
	close(f);
end;

function cmp(a,b:plista):boolean;
var
	i:integer;
begin
	for i:=1 to n do
		if a^.v[i]<>b^.v[i] then
		begin
			cmp:=false;
			exit;
			end;
	cmp:=true;
end;

function cauta(l:plista):boolean;
var
	p: plista;
begin
	p:=ct[l^.cst,disp1(l),disp2(l)];
	while p<>nil do
	begin
		if cmp(p,l) then
		begin
			cauta:=true;
			exit;
			end;
		p:=p^.next;
		end;
	cauta:=false;
end;

procedure expand(p:plista);
var
	i,j: integer;
	l: lista;
	p2: plista;
	tt1,tt2:integer;
begin
	for i:=1 to n do
		for j:=1 to n do
		begin
			if ((p^.v[i] shr (j-2)) and 7 =0) and
				((p^.v[i-1] shr (j-1)) and 1 =0 ) and
				((p^.v[i+1] shr (j-1)) and 1 =0 ) then
				continue;
			l.v:=p^.v;
			sch(@l,i,j);
			if i>1 then
				sch(@l,i-1,j);
			if j>1 then
				sch(@l,i,j-1);
			if i<n then
				sch(@l,i+1,j);
			if j<n then
				sch(@l,i,j+1);
			calc_cost(@l);
			if l.cst-cost_opt>EUR then
				continue;
			if (not cauta(@l)) then
			begin
				new(last^.next);
				last:=last^.next;
				last^.v:=l.v;
				last^.next:=nil;
				last^.parinte:=p;
				last^.cst:=l.cst;
				last^.a:=i;
				last^.b:=j;
				term;
				tt1:=disp1(last);
				tt2:=disp2(last);
				p2:=ct[l.cst,tt1,tt2];
				new(ct[l.cst,tt1,tt2]);
				ct[l.cst,tt1,tt2]^.next:=p2;
				ct[l.cst,tt1,tt2]^.v:=l.v;
				ct[l.cst,tt1,tt2]^.cst:=l.cst;
				if cost_opt>last^.cst then
					cost_opt:=last^.cst;
{				inc(sol);
				write(#13,sol,' ',cost_opt);}
				end;
			end;
end;

procedure calcul;
var
	p: plista;
begin
	p:=root;
	while p<>nil do
	begin
		expand(p);
		p:=p^.next;
		end;
end;

begin
	load;
	EUR:=vtmp[n];
	cost_opt:=root^.cst;
	term;
	calcul;
end.
------------------------------
Solutia 2 (Ovidiu ghiorghioiu)
{$b-}
var a,b,c,c0:array[0..15,0..15] of boolean;
    v:array[0..15,0..15] of byte;
    n,i,j,xx,yy,nr,nm,h:integer;
    f:text;
    cr:boolean;
    ch:char;

procedure citeste;
begin
     fillchar(a,sizeof(a),false);
     assign(f,'input.txt');reset(f);
     read(f,n);
     h:=0;
     for i:=1 to n do
         for j:=1 to n do begin
             if seekeof(f) then;
             read(f,ch);
             if ch='T' then a[i,j]:=true else inc(h);
         end;
     close(f)
end;

function checkv(x,y:integer):boolean;
begin
     dec(v[x,y]);
     if v[x,y]=0 then begin
        checkv:=true;
        cr:=not b[x,y]
     end else checkv:=false
end;

procedure touch(var b:boolean);
begin
     b:=not b;
     if b then dec(h) else inc(h)
end;

procedure flip(x,y:integer);
begin
     c[x,y]:=not c[x,y];
     touch(b[x,y]);
     if x>1 then touch(b[x-1,y]);
     if y>1 then touch(b[x,y-1]);
     if x<n then touch(b[x+1,y]);
     if y<n then touch(b[x,y+1])
end;

procedure getnext(x,y:integer);
begin
     if y=1 then begin
        xx:=1;
        yy:=x+1;
     end else
         if x<y then begin
            xx:=x+1;
            yy:=y
         end else begin
             xx:=x;
             yy:=y-1
         end;
end;
procedure back(x,y:integer);
begin
     if y>n then
        if h=0 then begin
           nm:=nr;
           c0:=c
        end else
     else begin
          dec(v[x,y+1]);
          dec(v[x+1,y]);
     {$b+}
          if checkv(x-1,y) or
             checkv(x,y-1) then begin
     {$b-}
               if cr then
                  if nr<nm-1 then begin
                     flip(x,y);
                     inc(nr);
                     getnext(x,y);
                     back(xx,yy);
                     flip(x,y);
                     dec(nr);
                  end else
               else begin
                    getnext(x,y);
                    back(xx,yy);
               end
          end else begin
              getnext(x,y);
              back(xx,yy);
              if nr<nm-1 then begin
                 flip(x,y);
                 inc(nr);
                 getnext(x,y);
                 back(xx,yy);
                 flip(x,y);
                 dec(nr)
              end;
          end;
          inc(v[x-1,y]);
          inc(v[x,y-1]);
          inc(v[x,y+1]);
          inc(v[x+1,y])
     end;
end;

procedure rezolva;
begin
     fillchar(v,sizeof(v),255);
     for i:=1 to n do
         for j:=1 to n do v[i,j]:=ord(i>1)+ord(j>1)+ord(i<n)+ord(j<n);
     b:=a;
     fillchar(c,sizeof(c),false);
     nr:=0;
     nm:=255;
     back(1,1);
end;

procedure scrie;
begin
     assign(f,'output.txt');
     rewrite(f);
     writeln(f,nm);
     for i:=1 to n do begin
         for j:=1 to n-1 do write(f,byte(c0[i,j]),' ');
         writeln(f,byte(c0[i,n]))
     end;
     close(f);
end;

begin
     citeste;
     rezolva;
     scrie
end.
--------------------------------
Solutia 3 (Valentin Gheorghita)
{$A+,B-,D+,E+,F-,G-,I+,L+,N-,O-,P-,Q-,R-,S+,T-,V+,X+,Y+}
{$M 16384,0,655360}
program HEADS_AND_TAILS;
uses crt;
type matrice=array[0..11,0..11] of boolean;
     matint=array[1..10,1..10] of byte;
     inr=^rec;
     rec=record
          st,dr:inr;
          f,g:integer;
          a:matrice;
          b:matint;
         end;
var a:matrice;
    b:matint;
    op,cl,tmp,temp:inr;
    ch:char;
    f:text;
    test:boolean;
    minf,ming,i,j,n:integer;

function functie(a:matrice):integer;
 var i,j,f:integer;
 begin
  f:=0;
  for i:=1 to n-1 do
   for j:=1 to n-1 do
    begin
     if a[i,j] and a[i,j+1] then f:=f+1;
     if a[i,j] and a[i+1,j] then f:=f+1;
    end;
   functie:=f;
 end;

function solutie(a:matrice):boolean;
 var i,j:integer;
     tst:boolean;
 begin
  tst:=false;
  for i:=1 to n do
   if not(tst) then
    for j:=1 to n do
     tst:=tst or a[i,j];
  solutie:=not(tst);
 end;


procedure tiparire(cat:integer;b:matint);
 var i,j:integer;
 begin
  assign(f,'OUTPUT.TXT');
  rewrite(f);
  writeln(f,cat);
  for i:=1 to n do
   begin
    for j:=1 to n do
     write(f,b[i,j],' ');
    writeln(f);
   end;
  close(f);
  halt;
 end;

function exist(i,j:integer;a:matrice):boolean;
 var k:integer;
 begin
  for k:=1 to n do
   begin
    a[0,k]:=false;
    a[k,0]:=false;
    a[k,n+1]:=false;
    a[n+1,k]:=false;
   end;
  if a[i,j] or a[i-1,j] or a[i+1,j] or a[i,j-1] or a[i,j+1] then exist:=true
                                                            else exist:=false;
 end;

function egalitate(c,d:matrice):boolean;
 var i,j:integer;
     tst:boolean;
 begin
  tst:=true;
  for i:=1 to n do
   if tst then
    for j:=1 to n do
     if c[i,j]<>d[i,j] then tst:=false;
  egalitate:=tst;
 end;


begin
 clrscr;
 assign(f,'INPUT.TXT');
 reset(f);
 readln(f,n);
 for i:=1 to n do
  begin
   for j:=1 to n do
    if not(seekeoln(f)) then begin
                              read(f,ch);
                              if ch='H' then a[i,j]:=true
                                        else a[i,j]:=false;
                             end;
  readln(f);
 end;
 close(f);
 new(op);
 new(tmp);
 op^.st:=nil;
 op^.dr:=tmp;
 tmp^.st:=op;
 tmp^.dr:=nil;
 new(cl);
 new(tmp);
 cl^.st:=nil;
 cl^.dr:=tmp;
 tmp^.st:=cl;
 tmp^.dr:=nil;
 for i:=1 to n do
  for j:=1 to n do
   b[i,j]:=0;
 if solutie(a) then tiparire(0,b);
 new(tmp);
 tmp^.a:=a;
 tmp^.b:=b;
 tmp^.st:=op;
 tmp^.dr:=op^.dr;
 tmp^.dr^.st:=tmp;
 op^.dr:=tmp;
 tmp^.g:=0;
 tmp^.f:=functie(a);
 while(op^.dr^.dr<>nil) do
  begin
   tmp:=op^.dr;
   minf:=maxint;
   ming:=maxint;
   while (tmp^.dr<>nil) do
    begin
     if tmp^.g<ming then begin
                          temp:=tmp;
                          ming:=tmp^.g;
                          minf:=tmp^.f;
                         end
     else if (tmp^.g=ming) and (tmp^.f<minf) then begin
                                                   temp:=tmp;
                                                   ming:=tmp^.g;
                                                   minf:=tmp^.f;
                                                  end;
     tmp:=tmp^.dr;
    end;
   temp^.st^.dr:=temp^.dr;
   temp^.dr^.st:=temp^.st;
   temp^.dr:=cl^.dr;
   cl^.dr^.st:=temp;
   cl^.dr:=temp;
   temp^.st:=cl;
   for i:=1 to n do
    for j:=1 to n do
     if (temp^.b[i,j]<>1) and exist(i,j,temp^.a) then begin
                              b:=temp^.b;
                              b[i,j]:=1;
                              a:=temp^.a;
                              a[i,j]:=not(a[i,j]);
                              a[i-1,j]:=not(a[i-1,j]);
                              a[i+1,j]:=not(a[i+1,j]);
                              a[i,j+1]:=not(a[i,j+1]);
                              a[i,j-1]:=not(a[i,j-1]);
                              if solutie(a) then tiparire(temp^.g+1,b);
                              test:=true;
                              tmp:=op^.dr;
                              while tmp^.dr<>nil do
                                begin
                                 if egalitate(a,tmp^.a) then test:=false;
                                 tmp:=tmp^.dr;
                                end;
                              tmp:=cl^.dr;
                              while tmp^.dr<>nil do
                                begin
                                 if egalitate(tmp^.a,a) then test:=false;
                                 tmp:=tmp^.dr;
                                end;
                              if test then begin
                                            new(tmp);
                                            tmp^.b:=b;
                                            tmp^.a:=a;
                                            tmp^.g:=temp^.g+1;
                                            tmp^.f:=functie(a);
                                            op^.dr^.st:=tmp;
                                            tmp^.dr:=op^.dr;
                                            tmp^.st:=op;
                                            op^.dr:=tmp;
                                           end;
                           end;
  end;
end.
--------------------------------
Solutia 4 (Angel Proorocu, Bucuresti)
program CapSiStema;

  uses Crt;

  type q=set of byte;
       nod=^ref;
       ref=record
         folos:q;
         f,g:byte;
         lista:char;
         urm,tata:nod;
        end;

  var prim,ultim,gasit,selectat:nod;
      demodificat:q;
      a,deafis:array[1..10,1..10]of char;
      f:text;
      ff:byte;
      n,i,j:integer;

procedure ReadData;
  var i,j:integer;
  begin
    assign(f,'input.txt');
    reset(f);
    readln(f,n);
    for i:=1 to n do
     begin
      for j:=1 to n do
        begin
          read(f,a[i,j]);
          while a[i,j]=' ' do read(f,a[i,j]);
        end;
      readln(f);
     end;
    close(f);
    ff:=0;
    demodificat:=[];
    for i:=1 to n do for j:=1 to n do
      if a[i,j] in ['h','H'] then
       begin
         demodificat:=demodificat+[(i-1)*n+j];
         ff:=ff+1;
       end;
  end;

function inopcl(aa:q):boolean;
  var pp:nod;
  begin
    inopcl:=false;
    pp:=prim;
    repeat
     pp:=pp^.urm;
     if aa=pp^.folos then
       begin
         inopcl:=true;
         gasit:=pp;
         exit;
       end;
    until pp=ultim;
  end;

function CelMaiConvenabil:nod;
  var p:nod;
      fmin:byte;
  begin
    fmin:=250;
    p:=prim;
    repeat
     p:=p^.urm;
     if p^.lista='o' then
        if fmin>p^.f then
         begin
          fmin:=p^.f;
          CelMaiConvenabil:=p;
         end;
    until p=ultim;
  end;

procedure adaugaopcl(p:nod);
  begin
   ultim^.urm:=p;
   ultim:=ultim^.urm;
  end;

procedure expand(ff,gg:integer; fll:q; tat:nod);
   var i,j,k:integer;
       p:nod;
   begin
     for i:=1 to n do for j:=1 to n do
      begin
       new(p);
       p^.tata:=tat;
       p^.folos:=fll;
       p^.f:=ff+1;
       p^.g:=gg+1;
       if (i-1)*n+j in p^.folos then
          begin
           p^.folos:=p^.folos-[(i-1)*n+j];
           dec(p^.f,1);
          end
        else
          begin
           p^.folos:=p^.folos+[(i-1)*n+j];
           inc(p^.f,1);
          end;
       if i-1>0 then
        if (i-2)*n+j in p^.folos then
           begin
            p^.folos:=p^.folos-[(i-2)*n+j];
            dec(p^.f,1);
           end
         else
           begin
            p^.folos:=p^.folos+[(i-2)*n+j];
            inc(p^.f,1);
           end;
       if j-1>0 then
        if (i-1)*n+j-1 in p^.folos then
          begin
           p^.folos:=p^.folos-[(i-1)*n+j-1];
           dec(p^.f,1);
          end
         else
          begin
           p^.folos:=p^.folos+[(i-1)*n+j-1];
           inc(p^.f,1);
          end;
       if i+1<n+1 then
         if i*n+j in p^.folos then
           begin
            p^.folos:=p^.folos-[i*n+j];
            dec(p^.f,1);
           end
         else
           begin
            p^.folos:=p^.folos+[i*n+j];
            inc(p^.f,1);
           end;
       if j+1<n+1 then
         if (i-1)*n+j+1 in p^.folos then
          begin
           p^.folos:=p^.folos-[(i-1)*n+j+1];
           dec(p^.f,1);
          end
        else
          begin
           p^.folos:=p^.folos+[(i-1)*n+j+1];
           inc(p^.f,1);
          end;

        if inopcl(p^.folos) then
          begin
           if p^.g<gasit^.g then
             begin
               gasit^.f:=p^.f;
               gasit^.g:=p^.g;
               gasit^.tata:=tat;
               if gasit^.lista='c' then gasit^.lista:='o';
             end;
           dispose(p);
          end
         else
         begin
          p^.lista:='o';
          adaugaopcl(p);
         end;
      end;
   end;

function valid(l,c:integer):integer;
   begin
    valid:=1;
    if (l<1)or(c<1)or(l>n)or(c>n) then exit;
    valid:=0;
    if a[l,c]='0' then exit;
    valid:=2;
   end;

procedure writesol(pp:nod);
   var i,j,hm,max,xx,yy:integer;
       mm:q;
   begin
       max:=0;
       if pp^.tata^.tata<>nil then writesol(pp^.tata);

       mm:=(pp^.folos-pp^.tata^.folos)+(pp^.tata^.folos-pp^.folos);

       for i:=1 to n do for j:=1 to n do
        if (i-1)*n+j in mm then a[i,j]:='1'
                     else a[i,j]:='0';
       for i:=1 to n do for j:=1 to n do
        begin
         hm:=valid(i,j+1)+valid(i,j-1)+valid(i-1,j)+valid(i+1,j);
         if hm>max then
          begin
           max:=hm;
           xx:=i;
           yy:=j;
          end;
       end;
     deafis[xx,yy]:='1';
  end;

begin
   clrscr;
   ReadData;
   new(prim);
   new(ultim);
   prim^.urm:=ultim;
   ultim^.folos:=demodificat;
   ultim^.f:=ff;
   ultim^.g:=0;
   ultim^.tata:=nil;
   ultim^.lista:='o';

   selectat:=CelMaiConvenabil;

   while (selectat^.folos<>[])  do
    begin
     expand(selectat^.f,selectat^.g,selectat^.folos,selectat);
     selectat^.lista:='c';
     selectat:=nil;
     selectat:=CelMaiConvenabil;
    end;
   writeln('Am gasit solutia....');
   assign(f,'output.txt');
    for i:=1 to n do for j:=1 to n do deafis[i,j]:='0';
   rewrite(f);
   WriteSol(selectat);
   writeln(f,selectat^.g);
   for i:=1 to n do
    begin
     for j:=1 to n do write(f,deafis[i,j],' ');
     writeln(f);
    end;
   close(f);
   writeln('Rezultatul este in OUTPUT.TXT');
   readkey;
end.
-------------------------------
Solutia 5 (Mihai Stroe)
var c,cc:char;
    a,b,x,y:array[0..11,0..11]of byte;
    i,j,k,l,m,n,nr,opt:longint;
    fi,fo:text;

procedure readdata;
begin
  assign(fi,'input.txt');
  assign(fo,'output.txt');
  reset(fi);
  rewrite(fo);
  readln(fi,n);
  for i:=1 to n do
      begin
        for j:=1 to n do
            begin
              read(fi,cc,c);
              if cc='T' then a[i,j]:=0 else a[i,j]:=1;
            end;
        if c=#13 then read(fi,c) else readln(fi);
      end;
  close(fi);
end;

procedure flip(i,j:longint);
begin
  a[i,j]:=1-a[i,j];
  a[i,j-1]:=1-a[i,j-1];
  a[i,j+1]:=1-a[i,j+1];
  a[i-1,j]:=1-a[i-1,j];
  a[i+1,j]:=1-a[i+1,j];
  x[i,j]:=1;
  inc(nr);
end;

procedure rez;
begin
  a:=b;
  for i:=2 to n do
      for j:=1 to n do
          x[i,j]:=0;
  nr:=0;
  for i:=1 to n do
      if x[1,i]=1 then
         flip(1,i);
  for i:=2 to n do
      for j:=1 to n do
          if a[i-1,j]=1 then
             flip(i,j);
  for i:=1 to n do
      if a[n,i]=1 then
         exit;
  if nr<opt then
     begin
       opt:=nr;
       y:=x;
     end;
end;

procedure back(k:longint);
begin
  if k=n+1 then
     begin
       rez;
       exit;
     end;
  x[1,k]:=1;
  back(k+1);
  x[1,k]:=0;
  back(k+1);
end;

procedure solve;
begin
  b:=a;
  opt:=n*n+1;
  back(1);
  writeln(fo,opt);
  for i:=1 to n do
      begin
        for j:=1 to n do
            write(fo,y[i,j],' ');
        writeln(fo);
      end;
  close(fo);
end;

begin
  readdata;
  solve;
end.
--------------------------
Solutia 6 (Valentin Gheorghita)
program HEADS_AND_TAILS;
uses crt;
type matrice=array[0..11,0..11] of boolean;
     matint=array[1..10,1..10] of byte;
     inr=^rec;
     rec=record
          st,dr:inr;
          f,g:integer;
          a:matrice;
          b:matint;
         end;
var a:matrice;
    b:matint;
    op,cl,tmp,temp:inr;
    ch:char;
    f:text;
    test:boolean;
    minf,ming,i,j,n:integer;

function functie(a:matrice):integer;
 var i,j,f:integer;
 begin
  f:=0;
  for i:=1 to n-1 do
   for j:=1 to n-1 do
    begin
     if a[i,j] and a[i,j+1] then f:=f+1;
     if a[i,j] and a[i+1,j] then f:=f+1;
    end;
   functie:=f;
 end;

function solutie(a:matrice):boolean;
 var i,j:integer;
     tst:boolean;
 begin
  tst:=false;
  for i:=1 to n do
   if not(tst) then
    for j:=1 to n do
     tst:=tst or a[i,j];
  solutie:=not(tst);
 end;


procedure tiparire(cat:integer;b:matint);
 var i,j:integer;
 begin
  assign(f,'OUTPUT.TXT');
  rewrite(f);
  writeln(f,cat);
  for i:=1 to n do
   begin
    for j:=1 to n do
     write(f,b[i,j],' ');
    writeln(f);
   end;
  close(f);
  halt;
 end;

function exist(i,j:integer;a:matrice):boolean;
 var k:integer;
 begin
  for k:=1 to n do
   begin
    a[0,k]:=false;
    a[k,0]:=false;
    a[k,n+1]:=false;
    a[n+1,k]:=false;
   end;
  if a[i,j] or a[i-1,j] or a[i+1,j] or a[i,j-1] or a[i,j+1] then exist:=true
                                                            else exist:=false;
 end;

function egalitate(c,d:matrice):boolean;
 var i,j:integer;
     tst:boolean;
 begin
  tst:=true;
  for i:=1 to n do
   if tst then
    for j:=1 to n do
     if c[i,j]<>d[i,j] then tst:=false;
  egalitate:=tst;
 end;


begin
 clrscr;
 assign(f,'INPUT.TXT');
 reset(f);
 readln(f,n);
 for i:=1 to n do
  begin
   for j:=1 to n do
    if not(seekeoln(f)) then begin
                              read(f,ch);
                              if ch='H' then a[i,j]:=true
                                        else a[i,j]:=false;
                             end;
  readln(f);
 end;
 close(f);
 new(op);
 new(tmp);
 op^.st:=nil;
 op^.dr:=tmp;
 tmp^.st:=op;
 tmp^.dr:=nil;
 new(cl);
 new(tmp);
 cl^.st:=nil;
 cl^.dr:=tmp;
 tmp^.st:=cl;
 tmp^.dr:=nil;
 for i:=1 to n do
  for j:=1 to n do
   b[i,j]:=0;
 if solutie(a) then tiparire(0,b);
 new(tmp);
 tmp^.a:=a;
 tmp^.b:=b;
 tmp^.st:=op;
 tmp^.dr:=op^.dr;
 tmp^.dr^.st:=tmp;
 op^.dr:=tmp;
 tmp^.g:=0;
 tmp^.f:=functie(a);
 while(op^.dr^.dr<>nil) do
  begin
   tmp:=op^.dr;
   minf:=maxint;
   ming:=maxint;
   while (tmp^.dr<>nil) do
    begin
     if tmp^.g<ming then begin
                          temp:=tmp;
                          ming:=tmp^.g;
                          minf:=tmp^.f;
                         end
     else if (tmp^.g=ming) and (tmp^.f<minf) then begin
                                                   temp:=tmp;
                                                   ming:=tmp^.g;
                                                   minf:=tmp^.f;
                                                  end;
     tmp:=tmp^.dr;
    end;
   temp^.st^.dr:=temp^.dr;
   temp^.dr^.st:=temp^.st;
   temp^.dr:=cl^.dr;
   cl^.dr^.st:=temp;
   cl^.dr:=temp;
   temp^.st:=cl;
   for i:=1 to n do
    for j:=1 to n do
     if (temp^.b[i,j]<>1) and exist(i,j,temp^.a) then begin
                              b:=temp^.b;
                              b[i,j]:=1;
                              a:=temp^.a;
                              a[i,j]:=not(a[i,j]);
                              a[i-1,j]:=not(a[i-1,j]);
                              a[i+1,j]:=not(a[i+1,j]);
                              a[i,j+1]:=not(a[i,j+1]);
                              a[i,j-1]:=not(a[i,j-1]);
                              if solutie(a) then tiparire(temp^.g+1,b);
                              test:=true;
                              tmp:=op^.dr;
                              while tmp^.dr<>nil do
                                begin
                                 if egalitate(a,tmp^.a) then test:=false;
                                 tmp:=tmp^.dr;
                                end;
                              tmp:=cl^.dr;
                              while tmp^.dr<>nil do
                                begin
                                 if egalitate(tmp^.a,a) then test:=false;
                                 tmp:=tmp^.dr;
                                end;
                              if test then begin
                                            new(tmp);
                                            tmp^.b:=b;
                                            tmp^.a:=a;
                                            tmp^.g:=temp^.g+1;
                                            tmp^.f:=functie(a);
                                            op^.dr^.st:=tmp;
                                            tmp^.dr:=op^.dr;
                                            tmp^.st:=op;
                                            op^.dr:=tmp;
                                           end;
                           end;
  end;
end.
----------------------------
